#!/usr/bin/perl
# permissions.pl
# Copyright (C) 2006, 2007  Stephane Alnet
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 3
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
# 

#
# For more information: http://carrierclass.net/
#
use strict;
use warnings;
use CGI;
use Carp;
use Apache::DBI;

use DBD::SQLite;
our $db = '/home/www/data/server/permissions.sqlite3';

our $dbh = DBI->connect("dbi:SQLite:dbname=$db","","",{ RaiseError => 1, AutoCommit => 1 })
    or die "DBI_connect($db): ".$DBI::errstr;

our $cgi = new CGI();

sub exit_failed($)
{
    croak shift;
}

# --- Database access

sub get_db_value
{
    my $query = shift;
    my $sth = $dbh->prepare($query) or exit_failed($dbh->errstr);
    $sth->execute(@_) or exit_failed($dbh->errstr);
    my @row = $sth->fetchrow_array;
    return undef if $#row < 0;
    return $row[0];
}

sub get_db_value_for_group_item($$)
{
    return get_db_value(q(SELECT value FROM group_item WHERE "group" = ? AND item = ?),@_);
}

sub get_db_value_for_login_item($$$)
{
    return get_db_value('SELECT value FROM login_item WHERE "group" = ? AND item = ? AND login = ?',@_);
}

# --- Ternary Logic And

# true  = 1
# false = 0
# undef = undef

# --- Lower-level logic

sub this_group_can_do_this_item($$)
{
    my ($group,$item) = @_;
    my $permission = get_db_value_for_group_item($group,$item);
    # permission can be: undef, true (>0) or false (<=0)
    return undef if not defined $permission;
    return $permission > 0;
}

sub login_can_do_this_item($$$)
{
    my ($group,$item,$login) = @_;
    my $permission = get_db_value_for_login_item($group,$item,$login);
    # permission can be: undef, true (>0) or false (<=0)
    return undef if not defined $permission;
    return $permission > 0;
}

# --- Group manipulation

sub the_parent_group_of($)
{
    my ($group) = @_;
    my @group = split(/\./,$group);
    shift @group;             # remove first component
    return join('.',@group);
}

sub is_root_group($)
{
    my ($group) = @_;
    return $group eq ''     # correct
        or $group eq '.';   # coding mistake
}

# --- Item manipulation

sub the_parent_item_of($)
{
    my ($item) = @_;
    my @item = split(/\//,$item);
    pop @item;            # remove last component
    return join('.',@item);
}

sub is_root_item($)
{
    my ($item) = @_;
    return $item eq ''      # correct root
        or $item eq '/';    # coding mistake
}

# --- This group can do...
# Restrict the query to this very group (and not its ancestry).

sub this_group_can_do_parent_item($$)
{
    my ($group,$item) = @_;
    return undef if is_root_item($item);
    my $parent_item = the_parent_item_of($item);
    return this_group_can_do($group,$parent_item);
}

sub this_group_can_do($$)
{
    my ($group,$item) = @_;

    # Ternary
    my $l = this_group_can_do_this_item($group,$item);
    return 0 if defined $l and not $l;

    my $r = this_group_can_do_parent_item($group,$item);
    return 0 if defined $r and not $r;

    return 1 if defined $l and $l;
    return 1 if defined $r and $r;
    return undef;
}

# --- Group can do...
# This group and its ancestry.

sub parent_group_can_do($$)
{
    my ($group,$item) = @_;
    return undef if is_root_group($group);
    my $parent_group = the_parent_group_of($group);
    return group_can_do($parent_group,$item);
}

sub group_can_do($$)
{
    my ($group,$item) = @_;

    # Ternary
    my $l = this_group_can_do($group,$item);
    return 0 if defined $l and not $l;
    
    my $r = parent_group_can_do($group,$item);
    return 0 if defined $r and not $r;

    return 1 if defined $l and $l;
    return 1 if defined $r and $r;
    return undef;
}

# --- Login can do...

sub login_can_do_parent_item($$$)
{
    my ($group,$item,$login) = @_;
    return undef if is_root_item($item);
    my $parent_item = the_parent_item_of($item);
    return login_can_do($group,$parent_item,$login);
}

sub login_can_do($$$)
{
    my ($group,$item,$login) = @_;

    # Ternary
    my $l = login_can_do_this_item($group,$item,$login);
    return 0 if defined $l and not $l;

    my $r = login_can_do_parent_item($group,$item,$login);
    return 0 if defined $r and not $r;

    return 1 if defined $l and $l;
    return 1 if defined $r and $r;
    return undef;
}

# --- Generic can_do

sub can_do($$$)
{
    my ($group,$item,$login) = @_;

    # Ternary
    my $l = login_can_do($group,$item,$login);
    return 0 if defined $l and not $l;

    my $r = group_can_do($group,$item);
    return 0 if defined $r and not $r;

    return 1 if defined $l and $l;
    return 1 if defined $r and $r;
    return undef;
}

my $group = $cgi->param('group');
exit_failed('Missing group parameter')
    if not defined $group;
exit_failed('Invalid group parameter')
    unless length($group) < 1024 and
        ($group eq ''  # The Root Group
        or $group =~ /^[\w-]+(\.[\w-]+)*$/);

my $item = $cgi->param('item');
exit_failed('Missing item parameter')
    if not defined $item;
exit_failed('Invalid item parameter')
    unless length($item) < 1024 and $item =~ /^\w+(\/\w+)*$/;

my $login = $cgi->param('login');
exit_failed('Missing login parameter')
    if not defined $login;
exit_failed('Invalid login parameter')
    unless length($login) < 1024 and $login =~ /^[\w.-\/]+$/;

my $result = can_do($group,$item,$login);
my $text = defined $result ? ($result ? 'true' : 'false') : 'undef';

print $cgi->header(-type => 'text/json; charset=utf-8');
print qq({ "can_do" : "${text}" }\n);
